home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / xlispst.cpt / XLisp-Stat ƒ / Disk 1 / menus.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1990-08-15  |  6.3 KB  |  179 lines
  1. ;;;;
  2. ;;;; menus.lsp Menus for the Macintosh
  3. ;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
  4. ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
  5. ;;;; You may give out copies of this software; for conditions see the file
  6. ;;;; COPYING included with this distribution.
  7. ;;;;
  8.  
  9. (provide "menus")
  10.  
  11. ;;;;
  12. ;;;; Editing Methods
  13. ;;;;
  14.  
  15. (defmeth edit-window-proto :edit-selection ()
  16.     (send (send edit-window-proto :new)
  17.           :paste-stream (send self :selection-stream)))
  18.  
  19. (defmeth edit-window-proto :eval-selection ()
  20.   (let ((s (send self :selection-stream)))
  21.     (do ((expr (read s nil '*eof*) (read s nil '*eof*)))
  22.         ((eq expr '*eof*))
  23.       (eval expr))))
  24.  
  25. (let ((last-string ""))
  26.   (defmeth edit-window-proto :find ()
  27. "Method args: ()
  28. Opens dialog to get string to find and finds it. Beeps if not found."
  29.     (let ((s (get-string-dialog "String to find:" :initial last-string)))
  30.       (when s
  31.           (if (stringp s) (setq last-string s))
  32.           (unless (and (stringp s) (send self :find-string s))
  33.                   (sysbeep)))))
  34.   (defmeth edit-window-proto :find-again ()
  35.     (unless (and (stringp last-string) 
  36.                  (< 0 (length last-string))
  37.                  (send self :find-string last-string))
  38.             (sysbeep))))
  39.                   
  40. ;;;;
  41. ;;;; General Menu Methods and Functions
  42. ;;;;
  43. (defmeth menu-proto :find-item (str)
  44. "Method args: (str)
  45. Finds and returns menu item with tile STR."
  46.   (dolist (item (send self :items))
  47.     (if (string-equal str (send item :title)) (return item))))
  48.  
  49. (defun find-menu (title)
  50. "Args: (title)
  51. Finds and returns menu in the menu bar with title TITLE."
  52.   (dolist (i *hardware-objects*)
  53.           (let ((object (nth 2 i)))
  54.             (if (and (kind-of-p object menu-proto) 
  55.                      (send object :installed-p) 
  56.                      (string-equal (string title) (send object :title)))
  57.                 (return object)))))
  58.  
  59. (defun set-menu-bar (menus)
  60. "Args (menus)
  61. Makes the list MENUS the current menu bar."
  62.   (dolist (i *hardware-objects*)
  63.           (let ((object (nth 2 i)))
  64.             (if (kind-of-p object menu-proto) (send object :remove))))
  65.   (dolist (i menus) (send i :allocate) (send i :install)))
  66.   
  67. ;;;;
  68. ;;;; Apple Menu
  69. ;;;;
  70. (defvar *apple-menu* (send apple-menu-proto :new (string #\apple)))
  71. (send *apple-menu* :append-items 
  72.   (send menu-item-proto :new "About XLISP-STAT" :action 'about-xlisp-stat)
  73.   (send dash-item-proto :new))
  74.  
  75. ;;;;
  76. ;;;; File Menu
  77. ;;;;
  78. (defvar *file-menu* (send menu-proto :new "File"))
  79.  
  80. (defproto file-edit-item-proto '(message) '() menu-item-proto)
  81.  
  82. (defmeth file-edit-item-proto :isnew (title message &rest args)
  83.   (setf (slot-value 'message) message)
  84.   (apply #'call-next-method title args))
  85.   
  86. (defmeth file-edit-item-proto :do-action ()
  87.   (send (front-window) (slot-value 'message)))
  88.   
  89. (defmeth file-edit-item-proto :update ()
  90.   (send self :enabled (kind-of-p (front-window) edit-window-proto)))
  91.   
  92. (send *file-menu* :append-items 
  93.   (send menu-item-proto :new "Load" :key #\L :action
  94.     #'(lambda ()
  95.       (let ((f (open-file-dialog t)))
  96.         (when f (load f) (format t "; finished loading ~s~%" f)))))
  97.   (send dash-item-proto :new)
  98.   (send menu-item-proto :new "New Edit" :key #\N
  99.         :action #'(lambda () (send edit-window-proto :new)))
  100.   (send menu-item-proto :new "Open Edit" :key #\O
  101.         :action #'(lambda () (send edit-window-proto :new :bind-to-file t)))
  102.   (send dash-item-proto :new)
  103.   (send file-edit-item-proto :new "Save Edit" :save :key #\S)
  104.   (send file-edit-item-proto :new "Save Edit As" :save-as)
  105.   (send file-edit-item-proto :new "Save Edit Copy" :save-copy)
  106.   (send file-edit-item-proto :new "Revert Edit" :revert)
  107.   (send dash-item-proto :new)
  108.   (send menu-item-proto :new "Quit" :key #\Q :action 'exit))
  109.  
  110. ;;;;
  111. ;;;; Edit Menu
  112. ;;;;
  113. (defproto edit-menu-item-proto '(item message) '() menu-item-proto)
  114.  
  115. (defmeth edit-menu-item-proto :isnew (title item message &rest args)
  116.   (setf (slot-value 'item) item)
  117.   (setf (slot-value 'message) message)
  118.   (apply #'call-next-method title args))
  119.   
  120. (defmeth edit-menu-item-proto :do-action ()
  121.   (unless (system-edit (slot-value 'item))
  122.           (let ((window (front-window)))
  123.             (if window (send window (slot-value 'message))))))
  124.           
  125. (defvar *edit-menu* (send menu-proto :new "Edit"))
  126. (send *edit-menu* :append-items
  127.   (send edit-menu-item-proto :new "Undo" 0 :undo :enabled nil)
  128.   (send dash-item-proto :new)
  129.   (send edit-menu-item-proto :new "Cut" 2 :cut-to-clip :key #\X)
  130.   (send edit-menu-item-proto :new "Copy" 3 :copy-to-clip :key #\C)
  131.   (send edit-menu-item-proto :new "Paste" 4 :paste-from-clip :key #\V)
  132.   (send edit-menu-item-proto :new "Clear" 5 :clear :enabled nil)
  133.   (send dash-item-proto :new)
  134.   (send menu-item-proto :new "Copy-Paste" :key #\/ :action
  135.     #'(lambda () 
  136.       (let ((window (front-window)))
  137.         (when  window
  138.               (send window :copy-to-clip)
  139.               (send window :paste-from-clip)))))
  140.   (send dash-item-proto :new)
  141.   (send menu-item-proto :new "Find ..." :key #\F :action
  142.     #'(lambda () 
  143.       (let ((window (front-window))) 
  144.         (if window (send window :find)))))
  145.   (send menu-item-proto :new "Find Again" :key #\A :action
  146.     #'(lambda () 
  147.       (let ((window (front-window))) 
  148.         (if window (send window :find-again)))))
  149.   (send dash-item-proto :new)
  150.   (send menu-item-proto :new "Edit Selection" :action
  151.     #'(lambda () (send (front-window) :edit-selection)))
  152.   (send menu-item-proto :new "Eval Selection" :key #\E :action
  153.     #'(lambda () (send (front-window) :eval-selection))))
  154.  
  155. ;;;;
  156. ;;;; Command Menu
  157. ;;;;
  158. (defvar *command-menu* (send menu-proto :new "Command"))
  159. (send *command-menu* :append-items
  160.   (send menu-item-proto :new "Show XLISP-STAT"
  161.                         :action #'(lambda () (send *listener* :show-window)))
  162.   (send dash-item-proto :new)
  163.   (send menu-item-proto :new "Clean Up" :key #\, :action #'clean-up)
  164.   (send menu-item-proto :new "Toplevel" :key #\. :action #'top-level)
  165.   (send dash-item-proto :new)
  166.   (let ((item (send menu-item-proto :new "Dribble")))
  167.     (send item :action 
  168.         #'(lambda () 
  169.             (cond
  170.               ((send item :mark) (dribble) (send item :mark nil))
  171.               (t (let ((f (set-file-dialog "Dribble file:")))
  172.                    (when f
  173.                          (dribble f)
  174.                          (send item :mark t)))))))
  175.     item))
  176.  
  177. (defconstant *standard-menu-bar* 
  178.              (list *apple-menu* *file-menu* *edit-menu* *command-menu*))
  179.